home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / character.d < prev    next >
Lisp/Scheme  |  1987-06-04  |  13KB  |  652 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     character.d
  9.  
  10.     character routines
  11. */
  12.  
  13. #include "include.h"
  14.  
  15. object STreturn;
  16. object STspace;
  17. object STrubout;
  18. object STpage;
  19. object STtab;
  20. object STbackspace;
  21. object STlinefeed;
  22.  
  23. object STnewline;
  24.  
  25. @(defun standard_char_p (c)
  26.     int i;
  27. @
  28.     check_type_character(&c);
  29.     if (char_font(c) != 0 || char_bits(c) != 0)
  30.         @(return Cnil)
  31.     i = char_code(c);
  32.     if (' ' <= i && i < '\177' || i == '\n')
  33.         @(return Ct)
  34.     @(return Cnil)
  35. @)
  36.  
  37. @(defun graphic_char_p (c)
  38.     int i;
  39. @
  40.     check_type_character(&c);
  41.     if (char_font(c) != 0 || char_bits(c) != 0)
  42.         @(return Cnil)
  43.     i = char_code(c);
  44.     if (' ' <= i && ' ' < '\177')
  45.         @(return Ct)
  46.     @(return Cnil)
  47. @)
  48.  
  49. @(defun string_char_p (c)
  50. @
  51.     check_type_character(&c);
  52.     if (char_font(c) != 0 || char_bits(c) != 0)
  53.         @(return Cnil)
  54.     @(return Ct)
  55. @)
  56.  
  57. @(defun alpha_char_p (c)
  58.     int i;
  59. @
  60.     check_type_character(&c);
  61.     if (char_font(c) != 0 || char_bits(c) != 0)
  62.         @(return Cnil)
  63.     i = char_code(c);
  64.     if (isalpha(i))
  65.         @(return Ct)
  66.     else
  67.         @(return Cnil)
  68. @)
  69.  
  70. @(defun upper_case_p (c)
  71. @
  72.     check_type_character(&c);
  73.     if (char_font(c) != 0 || char_bits(c) != 0)
  74.         @(return Cnil)
  75.     if (isUpper(char_code(c)))
  76.         @(return Ct)
  77.     @(return Cnil)
  78. @)
  79.  
  80. @(defun lower_case_p (c)
  81. @
  82.     check_type_character(&c);
  83.     if (char_font(c) != 0 || char_bits(c) != 0)
  84.         @(return Cnil)
  85.     if (isLower(char_code(c)))
  86.         @(return Ct)
  87.     @(return Cnil)
  88. @)
  89.  
  90. @(defun both_case_p (c)
  91. @
  92.     check_type_character(&c);
  93.     if (char_font(c) != 0 || char_bits(c) != 0)
  94.         @(return Cnil)
  95.     if (isUpper(char_code(c)) || isLower(char_code(c)))
  96.         @(return Ct)
  97.     else
  98.         @(return Cnil)
  99. @)
  100.  
  101. /*
  102.     Digitp(i, r) returns the weight of code i
  103.     as a digit of radix r.
  104.     If r > 36 or i is not a digit, -1 is returned.
  105. */
  106. digitp(i, r)
  107. int i, r;
  108. {
  109.     if ('0' <= i && i <= '9' && 1 < r && i < '0' + r)
  110.         return(i - '0');
  111.     if ('A' <= i && 10 < r && r <= 36 && i < 'A' + (r - 10))
  112.         return(i - 'A' + 10);
  113.     if ('a' <= i && 10 < r && r <= 36 && i < 'a' + (r - 10))
  114.         return(i - 'a' + 10);
  115.     return(-1);
  116. }
  117.  
  118. @(defun digit_char_p (c &optional (r `make_fixnum(10)`))
  119.     int d;
  120. @
  121.     check_type_character(&c);
  122.     check_type_non_negative_integer(&r);
  123.     if (type_of(r) == t_bignum)
  124.         @(return Cnil)
  125.     if (char_font(c) != 0 || char_bits(c) != 0)
  126.         @(return Cnil)
  127.     d = digitp(char_code(c), fix(r));
  128.     if (d < 0)
  129.         @(return Cnil)
  130.     @(return `make_fixnum(d)`)
  131. @)
  132.  
  133. @(defun alphanumericp (c)
  134.     int i;
  135. @
  136.     check_type_character(&c);
  137.     if (char_font(c) != 0 || char_bits(c) != 0)
  138.         @(return Cnil)
  139.     i = char_code(c);
  140.     if (isalphanum(i))
  141.         @(return Ct)
  142.     else
  143.         @(return Cnil)
  144. @)
  145.  
  146. bool
  147. char_eq(x, y)
  148. object x, y;
  149. {
  150.     return(char_code(x) == char_code(y)
  151.         && char_bits(x) == char_bits(y)
  152.         && char_font(x) == char_font(y));
  153. }
  154.  
  155. @(defun char_eq (c &rest)
  156.     int i;
  157. @
  158.     for (i = 0;  i < narg;  i++)
  159.         check_type_character(&vs_base[i]);
  160.     for (i = 1;  i < narg;  i++)
  161.         if (!char_eq(vs_base[i-1], vs_base[i]))
  162.             @(return Cnil)
  163.     @(return Ct)
  164. @)
  165.  
  166. @(defun char_neq (c &rest)
  167.     int i, j;
  168. @
  169.     for (i = 0;  i < narg;  i++)
  170.         check_type_character(&vs_base[i]);
  171.     if (narg == 0)
  172.         @(return Ct)
  173.     for (i = 1;  i < narg;  i++)
  174.         for (j = 0;  j < i;  j++)
  175.             if (char_eq(vs_base[j], vs_base[i]))
  176.                 @(return Cnil)
  177.     @(return Ct)
  178. @)
  179.  
  180.  
  181. int
  182. char_cmp(x, y)
  183. object x, y;
  184. {
  185.     if (char_font(x) < char_font(y))
  186.         return(-1);
  187.     if (char_font(x) > char_font(y))
  188.         return(1);
  189.     if (char_bits(x) < char_bits(y))
  190.         return(-1);
  191.     if (char_bits(x) > char_bits(y))
  192.         return(1);
  193.     if (char_code(x) < char_code(y))
  194.         return(-1);
  195.     if (char_code(x) > char_code(y))
  196.         return(1);
  197.     return(0);
  198. }
  199.  
  200. Lchar_cmp(s, t)
  201. int s, t;
  202. {
  203.     int narg, i;
  204.  
  205.     narg = vs_top - vs_base;
  206.     if (narg == 0)
  207.         too_few_arguments();
  208.     for (i = 0; i < narg; i++)
  209.         check_type_character(&vs_base[i]);
  210.     for (i = 1; i < narg; i++)
  211.         if (s*char_cmp(vs_base[i], vs_base[i-1]) < t) {
  212.             vs_top = vs_base+1;
  213.             vs_base[0] = Cnil;
  214.             return;
  215.         }
  216.     vs_top = vs_base+1;
  217.     vs_base[0] = Ct;
  218. }
  219.  
  220. Lchar_l()  { Lchar_cmp( 1, 1); }
  221. Lchar_g()  { Lchar_cmp(-1, 1); }
  222. Lchar_le() { Lchar_cmp( 1, 0); }
  223. Lchar_ge() { Lchar_cmp(-1, 0); }
  224.  
  225.  
  226. bool
  227. char_equal(x, y)
  228. object x, y;
  229. {
  230.     int i, j;
  231.  
  232.     i = char_code(x);
  233.     j = char_code(y);
  234.     if (isLower(i))
  235.         i -= 'a' - 'A';
  236.     if (isLower(j))
  237.         j -= 'a' - 'A';
  238.     return(i == j);
  239. }
  240.  
  241. @(defun char_equal (c &rest)
  242.     int i;
  243. @
  244.     for (i = 0;  i < narg;  i++)
  245.         check_type_character(&vs_base[i]);
  246.     for (i = 1;  i < narg;  i++)
  247.         if (!char_equal(vs_base[i-1], vs_base[i]))
  248.             @(return Cnil)
  249.     @(return Ct)
  250. @)
  251.  
  252. @(defun char_not_equal (c &rest)
  253.     int i, j;
  254. @
  255.     for (i = 0;  i < narg;  i++)
  256.         check_type_character(&vs_base[i]);
  257.     for (i = 1;  i < narg;  i++)
  258.         for (j = 0;  j < i;  j++)
  259.             if (char_equal(vs_base[j], vs_base[i]))
  260.                 @(return Cnil)
  261.     @(return Ct)
  262. @)
  263.  
  264.  
  265. int
  266. char_compare(x, y)
  267. object x, y;
  268. {
  269.     int i, j;
  270.  
  271.     i = char_code(x);
  272.     j = char_code(y);
  273.     if (isLower(i))
  274.         i -= 'a' - 'A';
  275.     if (isLower(j))
  276.         j -= 'a' - 'A';
  277.     if (i < j)
  278.         return(-1);
  279.     else if (i == j)
  280.         return(0);
  281.     else
  282.         return(1);
  283. }
  284.  
  285. Lchar_compare(s, t)
  286. int s, t;
  287. {
  288.     int narg, i;
  289.  
  290.     narg = vs_top - vs_base;
  291.     if (narg == 0)
  292.         too_few_arguments();
  293.     for (i = 0; i < narg; i++)
  294.         check_type_character(&vs_base[i]);
  295.     for (i = 1; i < narg; i++)
  296.         if (s*char_compare(vs_base[i], vs_base[i-1]) < t) {
  297.             vs_top = vs_base+1;
  298.             vs_base[0] = Cnil;
  299.             return;
  300.         }
  301.     vs_top = vs_base+1;
  302.     vs_base[0] = Ct;
  303. }
  304.  
  305. Lchar_lessp()        { Lchar_compare( 1, 1); }
  306. Lchar_greaterp()     { Lchar_compare(-1, 1); }
  307. Lchar_not_greaterp() { Lchar_compare( 1, 0); }
  308. Lchar_not_lessp()    { Lchar_compare(-1, 0); }
  309.  
  310.  
  311. object
  312. coerce_to_character(x)
  313. object x;
  314. {
  315. BEGIN:
  316.     switch (type_of(x)) {
  317.     case t_fixnum:
  318.         if (0 <= fix(x) && fix(x) < CHCODELIM)
  319.             return(code_char(fix(x)));
  320.         break;
  321.  
  322.     case t_character:
  323.         return(x);
  324.  
  325.     case t_symbol:
  326.     case t_string:
  327.         if (x->st.st_fillp == 1)
  328.             return(code_char(x->ust.ust_self[0]));
  329.         break;
  330.     }
  331.     vs_push(x);
  332.     x = wrong_type_argument(Scharacter, x);
  333.     vs_pop;
  334.     goto BEGIN;
  335. }
  336.  
  337. @(defun character (x)
  338. @
  339.     @(return `coerce_to_character(x)`)
  340. @)
  341.  
  342. @(defun char_code (c)
  343. @
  344.     check_type_character(&c);
  345.     @(return `make_fixnum(char_code(c))`)
  346. @)
  347.  
  348. @(defun char_bits (c)
  349. @
  350.     check_type_character(&c);
  351.     @(return `make_fixnum(char_bits(c))`)
  352. @)
  353.  
  354. @(defun char_font (c)
  355. @
  356.     check_type_character(&c);
  357.     @(return `make_fixnum(char_font(c))`)
  358. @)
  359.  
  360. @(defun code_char (c &o (b `make_fixnum(0)`) (f `make_fixnum(0)`))
  361.     object x;
  362. @
  363.     check_type_non_negative_integer(&c);
  364.     check_type_non_negative_integer(&b);
  365.     check_type_non_negative_integer(&f);
  366.     if (type_of(c) == t_bignum)
  367.         @(return Cnil)
  368.     if (type_of(b) == t_bignum)
  369.         @(return Cnil)
  370.     if (type_of(f) == t_bignum)
  371.         @(return Cnil)
  372.     if (fix(c)>=CHCODELIM || fix(b)>=CHBITSLIM || fix(f)>=CHFONTLIM)
  373.         @(return Cnil)
  374.     if (fix(b) == 0 && fix(f) == 0)
  375.         @(return `code_char(fix(c))`)
  376.     x = alloc_object(t_character);
  377.     char_code(x) = fix(c);
  378.     char_bits(x) = fix(b);
  379.     char_font(x) = fix(f);
  380.     @(return x)
  381. @)
  382.  
  383. @(defun make_char (c &o (b `make_fixnum(0)`) (f `make_fixnum(0)`))
  384.     object x;
  385.     int code;
  386. @
  387.     check_type_character(&c);
  388.     code = char_code(c);
  389.     check_type_non_negative_integer(&b);
  390.     check_type_non_negative_integer(&f);
  391.     if (type_of(b) == t_bignum)
  392.         @(return Cnil)
  393.     if (type_of(f) == t_bignum)
  394.         @(return Cnil)
  395.     if (fix(b)>=CHBITSLIM || fix(f)>=CHFONTLIM)
  396.         @(return Cnil)
  397.     if (fix(b) == 0 && fix(f) == 0)
  398.         @(return `code_char(code)`)
  399.     x = alloc_object(t_character);
  400.     char_code(x) = code;
  401.     char_bits(x) = fix(b);
  402.     char_font(x) = fix(f);
  403.     @(return x)
  404. @)
  405.  
  406. @(defun char_upcase (c)
  407. @
  408.     check_type_character(&c);
  409.     if (char_font(c) != 0 || char_bits(c) != 0)
  410.         @(return c)
  411.     if (isLower(char_code(c)))
  412.         @(return `code_char(char_code(c) - ('a' - 'A'))`)
  413.     else
  414.         @(return c)
  415. @)
  416.  
  417. @(defun char_downcase (c)
  418. @
  419.     check_type_character(&c);
  420.     if (char_font(c) != 0 || char_bits(c) != 0)
  421.         @(return Cnil)
  422.     if (isUpper(char_code(c)))
  423.         @(return `code_char(char_code(c) + ('a' - 'A'))`)
  424.     else
  425.         @(return c)
  426. @)
  427.  
  428. int
  429. digit_weight(w, r)
  430. int w, r;
  431. {
  432.     if (r < 2 || r > 36 || w < 0 || w >= r)
  433.         return(-1);
  434.     if (w < 10)
  435.         return(w + '0');
  436.     else
  437.         return(w - 10 + 'A');
  438. }
  439.  
  440. @(defun digit_char (w
  441.             &optional
  442.             (r `make_fixnum(10)`)
  443.             (f `make_fixnum(0)`))
  444.     object x;
  445.     int dw;
  446. @
  447.     check_type_non_negative_integer(&w);
  448.     check_type_non_negative_integer(&r);
  449.     check_type_non_negative_integer(&f);
  450.     if (type_of(w) == t_bignum)
  451.         @(return Cnil)
  452.     if (type_of(r) == t_bignum)
  453.         @(return Cnil)
  454.     if (type_of(f) == t_bignum)
  455.         @(return Cnil)
  456.     dw = digit_weight(fix(w), fix(r));
  457.     if (dw < 0)
  458.         @(return Cnil)
  459.     if (fix(f) >= CHFONTLIM)
  460.         @(return Cnil)
  461.     if (fix(f) == 0)
  462.         @(return `code_char(dw)`)
  463.     x = alloc_object(t_character);
  464.     char_code(x) = dw;
  465.     char_bits(x) = 0;
  466.     char_font(x) = fix(f);
  467.     @(return x)
  468. @)
  469.  
  470. @(defun char_int (c)
  471.     int i;
  472. @
  473.     check_type_character(&c);
  474.     i = (char_font(c)*CHBITSLIM + char_bits(c))*CHCODELIM
  475.       + char_code(c);
  476.     @(return `make_fixnum(i)`)
  477. @)
  478.  
  479. @(defun int_char (x)
  480.     int i, c, b, f;
  481. @
  482.     check_type_non_negative_integer(&x);
  483.     if (type_of(x) == t_bignum)
  484.         @(return Cnil)
  485.     i = fix(x);
  486.     c = i % CHCODELIM;
  487.     i /= CHCODELIM;
  488.     b = i % CHBITSLIM;
  489.     i /= CHBITSLIM;
  490.     f = i % CHFONTLIM;
  491.     i /= CHFONTLIM;
  492.     if (i > 0)
  493.         @(return Cnil)
  494.     if (b == 0 && f == 0)
  495.         @(return `code_char(c)`)
  496.     x = alloc_object(t_character);
  497.     char_code(x) = c;
  498.     char_bits(x) = b;
  499.     char_font(x) = f;
  500.     @(return x)
  501. @)
  502.  
  503. @(defun char_name (c)
  504. @
  505.     check_type_character(&c);
  506.     if (char_bits(c) != 0 || char_font(c) != 0)
  507.         @(return Cnil)
  508.     switch (char_code(c)) {
  509.     case '\r':
  510.         @(return STreturn)
  511.  
  512.     case ' ':
  513.         @(return STspace)
  514.  
  515.     case '\177':
  516.         @(return STrubout)
  517.     
  518.     case '\f':
  519.         @(return STpage)
  520.  
  521.     case '\t':
  522.         @(return STtab)
  523.  
  524.     case '\b':
  525.         @(return STbackspace)
  526.  
  527.     case '\n':
  528.         @(return STnewline)
  529.     }
  530.     @(return Cnil)
  531. @)
  532.  
  533. @(defun name_char (s)
  534. @
  535.     s = coerce_to_string(s);
  536.     if (string_equal(s, STreturn))
  537.         @(return `code_char('\r')`)
  538.     if (string_equal(s, STspace))
  539.         @(return `code_char(' ')`)
  540.     if (string_equal(s, STrubout))
  541.         @(return `code_char('\177')`)
  542.     if (string_equal(s, STpage))
  543.         @(return `code_char('\f')`)
  544.     if (string_equal(s, STtab))
  545.         @(return `code_char('\t')`)
  546.     if (string_equal(s, STbackspace))
  547.         @(return `code_char('\b')`)
  548.     if (string_equal(s, STlinefeed) || string_equal(s, STnewline))
  549.         @(return `code_char('\n')`)
  550.     @(return Cnil)
  551. @)
  552.  
  553. @(defun char_bit (c n)
  554. @
  555.     check_type_character(&c);
  556.     FEerror("Cannot get char-bit of ~S.", 1, c);
  557. @)
  558.  
  559. @(defun set_char_bit (c n v)
  560. @
  561.     check_type_character(&c);
  562.     FEerror("Cannot set char-bit of ~S.", 1, c);
  563. @)
  564.  
  565. init_character()
  566. {
  567.     object ch;
  568.     int i;
  569.  
  570.     for (i = 0;  i < CHCODELIM;  i++) {
  571.         character_table[i].t = (short)t_character;
  572.         character_table[i].ch_code = i;
  573.         character_table[i].ch_font = 0;
  574.         character_table[i].ch_bits = 0;
  575.     }
  576. #ifdef AV
  577.     for (i = -128;  i < 0;  i++) {
  578.         character_table[i].t = (short)t_character;
  579.         character_table[i].ch_code = i+CHCODELIM;
  580.         character_table[i].ch_font = 0;
  581.         character_table[i].ch_bits = 0;
  582.     }
  583. #endif
  584.  
  585.      make_constant("CHAR-CODE-LIMIT", make_fixnum(CHCODELIM));
  586.      make_constant("CHAR-FONT-LIMIT", make_fixnum(CHFONTLIM));
  587.      make_constant("CHAR-BITS-LIMIT", make_fixnum(CHBITSLIM));
  588.  
  589.     STreturn = make_simple_string("RETURN");
  590.     enter_mark_origin(&STreturn);
  591.     STspace = make_simple_string("SPACE");
  592.     enter_mark_origin(&STspace);
  593.     STrubout = make_simple_string("RUBOUT");
  594.     enter_mark_origin(&STrubout);
  595.     STpage = make_simple_string("PAGE");
  596.     enter_mark_origin(&STpage);
  597.     STtab = make_simple_string("TAB");
  598.     enter_mark_origin(&STtab);
  599.     STbackspace = make_simple_string("BACKSPACE");
  600.     enter_mark_origin(&STbackspace);
  601.     STlinefeed = make_simple_string("LINEFEED");
  602.     enter_mark_origin(&STlinefeed);
  603.  
  604.     STnewline = make_simple_string("NEWLINE");
  605.     enter_mark_origin(&STnewline);
  606.  
  607.     make_constant("CHAR-CONTROL-BIT", make_fixnum(0));
  608.     make_constant("CHAR-META-BIT", make_fixnum(0));
  609.     make_constant("CHAR-SUPER-BIT", make_fixnum(0));
  610.     make_constant("CHAR-HYPER-BIT", make_fixnum(0));
  611. }
  612.  
  613. init_character_function()
  614. {
  615.     make_function("STANDARD-CHAR-P", Lstandard_char_p);
  616.     make_function("GRAPHIC-CHAR-P", Lgraphic_char_p);
  617.     make_function("STRING-CHAR-P", Lstring_char_p);
  618.     make_function("ALPHA-CHAR-P", Lalpha_char_p);
  619.     make_function("UPPER-CASE-P", Lupper_case_p);
  620.     make_function("LOWER-CASE-P", Llower_case_p);
  621.     make_function("BOTH-CASE-P", Lboth_case_p);
  622.     make_function("DIGIT-CHAR-P", Ldigit_char_p);
  623.     make_function("ALPHANUMERICP", Lalphanumericp);
  624.     make_function("CHAR=", Lchar_eq);
  625.     make_function("CHAR/=", Lchar_neq);
  626.     make_function("CHAR<", Lchar_l);
  627.     make_function("CHAR>", Lchar_g);
  628.     make_function("CHAR<=", Lchar_le);
  629.     make_function("CHAR>=", Lchar_ge);
  630.     make_function("CHAR-EQUAL", Lchar_equal);
  631.     make_function("CHAR-NOT-EQUAL", Lchar_not_equal);
  632.     make_function("CHAR-LESSP", Lchar_lessp);
  633.     make_function("CHAR-GREATERP", Lchar_greaterp);
  634.     make_function("CHAR-NOT-GREATERP", Lchar_not_greaterp);
  635.     make_function("CHAR-NOT-LESSP", Lchar_not_lessp);
  636.     make_function("CHARACTER", Lcharacter);
  637.     make_function("CHAR-CODE", Lchar_code);
  638.     make_function("CHAR-BITS", Lchar_bits);
  639.     make_function("CHAR-FONT", Lchar_font);
  640.     make_function("CODE-CHAR", Lcode_char);
  641.     make_function("MAKE-CHAR", Lmake_char);
  642.     make_function("CHAR-UPCASE", Lchar_upcase);
  643.     make_function("CHAR-DOWNCASE", Lchar_downcase);
  644.     make_function("DIGIT-CHAR", Ldigit_char);
  645.     make_function("CHAR-INT", Lchar_int);
  646.     make_function("INT-CHAR", Lint_char);
  647.     make_function("CHAR-NAME", Lchar_name);
  648.     make_function("NAME-CHAR", Lname_char);
  649.     make_function("CHAR-BIT", Lchar_bit);
  650.     make_function("SET-CHAR-BIT", Lset_char_bit);
  651. }
  652.